home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Atari Mega Archive 1
/
Atari Mega Archive - Volume 1.iso
/
language
/
xlispsrc.arc
/
XLLIST.C
< prev
next >
Wrap
C/C++ Source or Header
|
1988-02-11
|
20KB
|
916 lines
/* xllist.c - xlisp built-in list functions */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* forward declarations */
FORWARD LVAL cxr();
FORWARD LVAL nth(),assoc();
FORWARD LVAL subst(),sublis(),map();
/* xcar - take the car of a cons cell */
LVAL xcar()
{
LVAL list;
list = xlgalist();
xllastarg();
return (list ? car(list) : NIL);
}
/* xcdr - take the cdr of a cons cell */
LVAL xcdr()
{
LVAL list;
list = xlgalist();
xllastarg();
return (list ? cdr(list) : NIL);
}
/* cxxr functions */
LVAL xcaar() { return (cxr("aa")); }
LVAL xcadr() { return (cxr("da")); }
LVAL xcdar() { return (cxr("ad")); }
LVAL xcddr() { return (cxr("dd")); }
/* cxxxr functions */
LVAL xcaaar() { return (cxr("aaa")); }
LVAL xcaadr() { return (cxr("daa")); }
LVAL xcadar() { return (cxr("ada")); }
LVAL xcaddr() { return (cxr("dda")); }
LVAL xcdaar() { return (cxr("aad")); }
LVAL xcdadr() { return (cxr("dad")); }
LVAL xcddar() { return (cxr("add")); }
LVAL xcdddr() { return (cxr("ddd")); }
/* cxxxxr functions */
LVAL xcaaaar() { return (cxr("aaaa")); }
LVAL xcaaadr() { return (cxr("daaa")); }
LVAL xcaadar() { return (cxr("adaa")); }
LVAL xcaaddr() { return (cxr("ddaa")); }
LVAL xcadaar() { return (cxr("aada")); }
LVAL xcadadr() { return (cxr("dada")); }
LVAL xcaddar() { return (cxr("adda")); }
LVAL xcadddr() { return (cxr("ddda")); }
LVAL xcdaaar() { return (cxr("aaad")); }
LVAL xcdaadr() { return (cxr("daad")); }
LVAL xcdadar() { return (cxr("adad")); }
LVAL xcdaddr() { return (cxr("ddad")); }
LVAL xcddaar() { return (cxr("aadd")); }
LVAL xcddadr() { return (cxr("dadd")); }
LVAL xcdddar() { return (cxr("addd")); }
LVAL xcddddr() { return (cxr("dddd")); }
/* cxr - common car/cdr routine */
LOCAL LVAL cxr(adstr)
char *adstr;
{
LVAL list;
/* get the list */
list = xlgalist();
xllastarg();
/* perform the car/cdr operations */
while (*adstr && consp(list))
list = (*adstr++ == 'a' ? car(list) : cdr(list));
/* make sure the operation succeeded */
if (*adstr && list)
xlfail("bad argument");
/* return the result */
return (list);
}
/* xcons - construct a new list cell */
LVAL xcons()
{
LVAL arg1,arg2;
/* get the two arguments */
arg1 = xlgetarg();
arg2 = xlgetarg();
xllastarg();
/* construct a new list element */
return (cons(arg1,arg2));
}
/* xlist - built a list of the arguments */
LVAL xlist()
{
LVAL last,next,val;
/* protect some pointers */
xlsave1(val);
/* add each argument to the list */
for (val = NIL; moreargs(); ) {
/* append this argument to the end of the list */
next = consa(nextarg());
if (val) rplacd(last,next);
else val = next;
last = next;
}
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xappend - built-in function append */
LVAL xappend()
{
LVAL list,last,next,val;
/* protect some pointers */
xlsave1(val);
/* initialize */
val = NIL;
/* append each argument */
if (moreargs()) {
while (xlargc > 1) {
/* append each element of this list to the result list */
for (list = nextarg(); consp(list); list = cdr(list)) {
next = consa(car(list));
if (val) rplacd(last,next);
else val = next;
last = next;
}
}
/* handle the last argument */
if (val) rplacd(last,nextarg());
else val = nextarg();
}
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xreverse - built-in function reverse */
LVAL xreverse()
{
LVAL list,val;
/* protect some pointers */
xlsave1(val);
/* get the list to reverse */
list = xlgalist();
xllastarg();
/* append each element to the head of the result list */
for (val = NIL; consp(list); list = cdr(list))
val = cons(car(list),val);
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
/* xlast - return the last cons of a list */
LVAL xlast()
{
LVAL list;
/* get the list */
list = xlgalist();
xllastarg();
/* find the last cons */
while (consp(list) && cdr(list))
list = cdr(list);
/* return the last element */
return (list);
}
/* xmember - built-in function 'member' */
LVAL xmember()
{
LVAL x,list,fcn,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the list */
x = xlgetarg();
list = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(list); list = cdr(list))
if (dotest2(x,car(list),fcn) == tresult) {
val = list;
break;
}
/* restore the stack */
xlpop();
/* return the result */
return (val);
}
/* xassoc - built-in function 'assoc' */
LVAL xassoc()
{
LVAL x,alist,fcn,pair,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the association list */
x = xlgetarg();
alist = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest2(x,car(pair),fcn) == tresult) {
val = pair;
break;
}
/* restore the stack */
xlpop();
/* return result */
return (val);
}
/* xsubst - substitute one expression for another */
LVAL xsubst()
{
LVAL to,from,expr,fcn,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the to value, the from value and the expression */
to = xlgetarg();
from = xlgetarg();
expr = xlgetarg();
xltest(&fcn,&tresult);
/* do the substitution */
val = subst(to,from,expr,fcn,tresult);
/* restore the stack */
xlpop();
/* return the result */
return (val);
}
/* subst - substitute one expression for another */
LOCAL LVAL subst(to,from,expr,fcn,tresult)
LVAL to,from,expr,fcn; int tresult;
{
LVAL carval,cdrval;
if (dotest2(expr,from,fcn) == tresult)
return (to);
else if (consp(expr)) {
xlsave1(carval);
carval = subst(to,from,car(expr),fcn,tresult);
cdrval = subst(to,from,cdr(expr),fcn,tresult);
xlpop();
return (cons(carval,cdrval));
}
else
return (expr);
}
/* xsublis - substitute using an association list */
LVAL xsublis()
{
LVAL alist,expr,fcn,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the assocation list and the expression */
alist = xlgalist();
expr = xlgetarg();
xltest(&fcn,&tresult);
/* do the substitution */
val = sublis(alist,expr,fcn,tresult);
/* restore the stack */
xlpop();
/* return the result */
return (val);
}
/* sublis - substitute using an association list */
LOCAL LVAL sublis(alist,expr,fcn,tresult)
LVAL alist,expr,fcn; int tresult;
{
LVAL carval,cdrval,pair;
if (pair = assoc(expr,alist,fcn,tresult))
return (cdr(pair));
else if (consp(expr)) {
xlsave1(carval);
carval = sublis(alist,car(expr),fcn,tresult);
cdrval = sublis(alist,cdr(expr),fcn,tresult);
xlpop();
return (cons(carval,cdrval));
}
else
return (expr);
}
/* assoc - find a pair in an association list */
LOCAL LVAL assoc(expr,alist,fcn,tresult)
LVAL expr,alist,fcn; int tresult;
{
LVAL pair;
for (; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest2(expr,car(pair),fcn) == tresult)
return (pair);
return (NIL);
}
/* xremove - built-in function 'remove' */
LVAL xremove()
{
LVAL x,list,fcn,val,last,next;
int tresult;
/* protect some pointers */
xlstkcheck(2);
xlsave(fcn);
xlsave(val);
/* get the expression to remove and the list */
x =